home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / BBS-Archive / Dev / GNU-TILE-FORTH.lha / tst / minimal.f83 < prev    next >
Text File  |  1992-05-19  |  10KB  |  389 lines
  1. \
  2. \  A MINIMAL FORTH MACHINE SIMULATOR AND META-COMPILER
  3. \
  4. \  Copyright (C) 1989-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 1 August 1989
  15. \
  16. \  Last updated on: 23 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth
  20. \
  21. \  Description:
  22. \       This library illustrates how a virtual forth machine and most of
  23. \       the language can be realized with only nine primitive instructions.
  24. \       A simulator for the minimal forth virtual machine is defined
  25. \       together with a meta-compiler and implementations of a large
  26. \       section of the forth language.
  27. \
  28. \  Copying:
  29. \       This program is free software; you can redistribute it and\or modify
  30. \       it under the terms of the GNU General Public License as published by
  31. \       the Free Software Foundation; either version 1, or (at your option)
  32. \       any later version.
  33. \
  34. \       This program is distributed in the hope that it will be useful,
  35. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  36. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  37. \       GNU General Public License for more details.
  38. \
  39. \       You should have received a copy of the GNU General Public License
  40. \       along with this program; see the file COPYING.  If not, write to
  41. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  42.  
  43. .( Loading Minimal Forth Machine definitions...) cr
  44.  
  45. vocabulary minimal ( -- ) 
  46.  
  47. minimal definitions
  48.  
  49. forth
  50.  
  51. \ Hardware Devices: Registers and Stacks
  52.  
  53. : register ( -- ) create 0 , does> @ ;
  54. : -> ( x -- ) ' >body [compile] literal compile ! ; immediate compilation
  55. : stack ( n -- ) create here swap 2+ cells allot here over cell+ ! here swap ! ;
  56. : push ( x s -- ) cell negate over +! @ ! ;
  57. : pop ( s -- x) dup @ @ cell rot +! ;
  58. : empty ( s -- ) dup cell+ @ swap ! ;
  59. : ?empty ( s -- bool) 2@ = ;
  60. : .stack ( s -- ) dup cell + @ swap @ ?do i @ . cell +loop ;
  61.  
  62.  
  63. \ Forth Machine Registers
  64.  
  65. register tos ( -- x | Top of stack register)
  66. register ir ( -- x | Instruction register)
  67. register ip ( -- x | Instruction pointer)
  68. 64 stack rp ( -- s | Return address stack)
  69. 64 stack sp ( -- s | Parameter stack)
  70.  
  71. \ Dump machine state
  72.  
  73. : .registers ( -- )
  74.   ." ir: " ir .name space        ( Dump name of current instruction)
  75.   ." ip: " ip cell - .            ( Dump instruction pointer)
  76.   ." rp: " rp .stack            ( Dump return stack)
  77.   ." tos: " tos .            ( Dump top of stack register)
  78.   ." sp: " sp .stack cr         ( Dump parameter stack)
  79. ;
  80.  
  81.  
  82. \ Forth Machine Instructions
  83.  
  84. : instruction ( n -- ) create ; 
  85. : decode ( -- ) minimal [compile] ['] forth ; immediate compilation
  86.  
  87. instruction 1+
  88. instruction 0=
  89. instruction NAND
  90. instruction >R
  91. instruction R>
  92. instruction !
  93. instruction @
  94. instruction EXIT
  95. instruction DUMP
  96.  
  97. : CALL ( -- ) ip rp push ir >body -> ip ;
  98.  
  99.  
  100. \ The Minimal Forth Machine and additional state variables
  101.  
  102. variable trace ( -- addr | Trace function pointer)
  103. variable cycles ( -- addr | Instruction cycle counter)
  104. variable restart ( -- addr | Restart instruction pointer)
  105.  
  106. : reset-processor ( -- )
  107.   0 cycles !                ( Initiate cycle counter)
  108.   restart -> ip                ( And instruction pointer)
  109.   0 -> tos                ( Clear top of stack)
  110.   sp empty                ( And empty parameter stack)
  111.   rp empty                ( And return stack)
  112. ;
  113.  
  114. : fetch-instruction ( -- instruction)
  115.   1 cycles +!                ( Increment cycle counter)
  116.   ip @ dup -> ir            ( Fetch next instruction)
  117.   ip cell+ -> ip            ( And increment instruction pointer)
  118. ;
  119.  
  120. : processor ( -- )
  121.   reset-processor
  122.   begin
  123.     fetch-instruction
  124.     trace @ ?dup if execute then
  125.     case
  126.       decode 1+   of tos 1+ -> tos               endof
  127.       decode 0=   of tos 0= -> tos               endof
  128.       decode NAND of sp pop tos and not -> tos   endof
  129.       decode >R   of tos rp push sp pop -> tos   endof
  130.       decode R>   of tos sp push rp pop -> tos   endof
  131.       decode !    of sp pop tos ! sp pop -> tos  endof
  132.       decode @    of tos @ -> tos                endof
  133.       decode EXIT of rp pop -> ip                endof
  134.       decode DUMP of .registers                  endof
  135.       CALL
  136.     endcase
  137.     rp ?empty
  138.   until
  139. ;
  140.  
  141. : run ( -- ) ' restart ! processor ." cycles: " cycles @ . .registers ;
  142. : trace-instructions ( -- ) ['] .registers trace ! ;
  143.  
  144.  
  145. \ A simple meta-compiler for the Minimal Forth Machine
  146.  
  147. minimal
  148.  
  149. : CREATE ( -- ) create ; 
  150. : COMPILE ( -- ) compile compile ; immediate
  151.  
  152. : DEFINE ( -- ) CREATE ] ;
  153. : END ( -- ) COMPILE EXIT [compile] [ ; immediate
  154. : BLOCK ( n -- ) cells allot ;
  155. : DATA ( -- ) , ;
  156.  
  157.  
  158. \ Variable management
  159.  
  160. DEFINE [VARIABLE] ( -- addr) R> END
  161. : VARIABLE ( -- addr) CREATE COMPILE [VARIABLE] 1 BLOCK ; 
  162.  
  163.  
  164. \ Constant management
  165.  
  166. DEFINE [CONSTANT] ( -- n) R> @ END
  167. : CONSTANT ( n -- ) CREATE COMPILE [CONSTANT] DATA ;
  168.  
  169.  
  170. \ Basic stack manipulation functions
  171.  
  172. VARIABLE TEMP ( -- addr)
  173.  
  174. DEFINE DROP ( x -- ) TEMP ! END
  175. DEFINE DUP ( x -- x x) TEMP ! TEMP @ TEMP @ END
  176. DEFINE SWAP ( x y -- y x) TEMP ! >R TEMP @ R> END
  177. DEFINE ROT ( x y z -- y z x) >R SWAP R> SWAP END
  178. DEFINE OVER ( x y -- x y x) >R DUP R> SWAP END
  179. DEFINE R@ ( -- x) R> R> DUP >R SWAP >R END
  180.  
  181.  
  182. \ Basic logical functions
  183.  
  184. -1 CONSTANT TRUE ( -- true)
  185.  0 CONSTANT FALSE ( -- false)
  186.  
  187. DEFINE BOOLEAN ( x -- bool) 0= 0= END
  188. DEFINE NOT ( x y -- z) DUP NAND END
  189. DEFINE AND ( x y -- z) NAND NOT END
  190. DEFINE OR ( x y -- z) NOT SWAP NOT NAND END
  191. DEFINE XOR ( x y -- y) OVER OVER NOT NAND >R SWAP NOT NAND R> NAND END
  192.  
  193.  
  194. \ Primitive arithmetic constants and functions
  195.  
  196. -2147483648 CONSTANT MIN-INT ( -- int)
  197. -2 CONSTANT -2 ( -- int)
  198. -1 CONSTANT -1 ( -- int)
  199.  0 CONSTANT 0 ( -- int)
  200.  1 CONSTANT 1 ( -- int)
  201.  2 CONSTANT 2 ( -- int)
  202.  2147483647 CONSTANT MAX-INT ( -- int)
  203.  
  204. DEFINE 1- ( x -- y) NOT 1+ NOT END
  205. DEFINE 2+ ( x -- y) 1+ 1+ END
  206. DEFINE 2- ( x -- y) NOT 2+ NOT END
  207.  
  208.  
  209. \ Additional relational functions
  210.  
  211. DEFINE 0< ( x -- bool) MIN-INT AND BOOLEAN END
  212. DEFINE 0> ( x -- bool) DUP 0= SWAP 0< OR NOT BOOLEAN END
  213.  
  214.  
  215. \ Cell sizes and cell increment function
  216.  
  217. 4 CONSTANT CELL ( -- num)
  218. DEFINE CELL+ ( x -- y) 1+ 1+ 1+ 1+ END
  219.  
  220.  
  221. \ Branch functions
  222.  
  223. DEFINE (BRANCH) ( -- ) R> @ >R END
  224. DEFINE (?BRANCH) ( bool -- ) 0= DUP R@ @ AND SWAP NOT R> CELL+ AND OR >R END
  225.  
  226.  
  227. \ Compiler functions
  228.  
  229. : >MARK ( -- addr) here cell allot ;
  230. : >RESOLVE ( addr -- ) here swap (forth) ! ;
  231. : <MARK ( -- addr) here ;
  232. : <RESOLVE ( -- addr) , ;
  233.  
  234. : IF ( bool -- ) COMPILE (?BRANCH) >MARK ; immediate
  235. : ELSE ( -- ) COMPILE (BRANCH) >MARK swap >RESOLVE ; immediate
  236. : THEN ( -- ) >RESOLVE ; immediate
  237. : BEGIN ( -- ) <MARK ; immediate
  238. : WHILE ( bool -- ) COMPILE (?BRANCH) >MARK ; immediate
  239. : REPEAT ( -- ) COMPILE (BRANCH) swap <RESOLVE >RESOLVE ; immediate
  240. : UNTIL ( bool -- ) COMPILE (?BRANCH) <RESOLVE ; immediate
  241. : AGAIN ( -- ) COMPILE (BRANCH) <RESOLVE ; immediate
  242.  
  243.  
  244. \ Additional stack functions
  245.  
  246. DEFINE ?DUP ( n -- [n n] or [0]) DUP IF DUP THEN END
  247. DEFINE TUCK ( x y -- y x y) SWAP OVER END
  248. DEFINE NIP ( x y -- y) SWAP DROP END
  249. DEFINE 2DUP ( x y -- x y x y) OVER OVER END
  250. DEFINE 2DROP ( x y -- ) DROP DROP END
  251.  
  252.  
  253. \ Arithmetical functions
  254.  
  255.    
  256. DEFINE NEGATE ( x -- y) NOT 1+ END
  257. DEFINE ABS ( x -- y) DUP 0< IF NEGATE THEN END
  258.  
  259. DEFINE + ( x y -- z)
  260.   DUP 0<
  261.   IF BEGIN DUP WHILE 1+ SWAP 1- SWAP REPEAT 
  262.   ELSE BEGIN DUP WHILE 1- SWAP 1+ SWAP REPEAT THEN
  263.   DROP
  264. END
  265.  
  266. DEFINE - ( x y -- z) NEGATE + END
  267.  
  268. DEFINE U< ( x y -- bool)
  269.   BEGIN
  270.     DUP IF 1- ELSE 2DROP FALSE EXIT THEN
  271.     SWAP
  272.     DUP IF 1- ELSE 2DROP TRUE EXIT THEN
  273.     SWAP
  274.   AGAIN
  275. END
  276.   
  277. DEFINE U* ( x y -- z)
  278.   >R 0 SWAP
  279.   BEGIN DUP WHILE 1- SWAP R@ + SWAP REPEAT
  280.   R> 2DROP
  281. END
  282.  
  283. DEFINE U/MOD ( x y -- q r) 
  284.   >R 0 SWAP 
  285.   BEGIN DUP R@ - DUP 0< NOT WHILE SWAP DROP SWAP 1+ SWAP REPEAT
  286.   R> 2DROP
  287. END
  288.  
  289. DEFINE * ( x y -- z) 
  290.   2DUP XOR 0< >R
  291.   ABS SWAP ABS SWAP U*
  292.   R> IF NEGATE THEN
  293. END
  294.  
  295. DEFINE /MOD ( x y -- q r) 
  296.   2DUP XOR 0< >R OVER 0< >R 
  297.   ABS SWAP ABS SWAP U/MOD 
  298.   R> IF NEGATE THEN 
  299.   R> IF SWAP NEGATE SWAP THEN
  300. END
  301.  
  302. DEFINE / ( x y -- q) /MOD DROP END
  303. DEFINE MOD ( x y -- r) /MOD NIP END
  304.  
  305. DEFINE = ( x y -- bool) XOR BOOLEAN NOT END
  306. DEFINE < ( x y -- bool) - 0< END
  307. DEFINE > ( x y -- bool) - 0> END
  308.  
  309. DEFINE MIN ( x y -- z) 2DUP > IF SWAP THEN DROP END
  310. DEFINE MAX ( x y -- z) 2DUP < IF SWAP THEN DROP END
  311.  
  312.  
  313. \ Number literals in meta-code
  314.  
  315. DEFINE (LITERAL) ( -- ) R> DUP @ SWAP CELL+ >R END
  316. : LITERAL ( x -- ) COMPILE (LITERAL) , ; immediate
  317.  
  318.  
  319. \ And some test code just to show that it actually works
  320.  
  321. DEFINE LOGIC-TEST ( -- )
  322.   [ 5 ] LITERAL NOT
  323.   [ 5 ] LITERAL [ 3 ] LITERAL AND
  324.   [ 5 ] LITERAL [ 3 ] LITERAL OR
  325.   [ 5 ] LITERAL [ 3 ] LITERAL XOR
  326.  
  327.   [ 5 ] LITERAL 0=
  328.   [ 5 ] LITERAL 0<
  329.   [ 5 ] LITERAL 0>
  330.  
  331.   [ 5 ] LITERAL [ 3 ] LITERAL =
  332.   [ 5 ] LITERAL [ 3 ] LITERAL <
  333.   [ 5 ] LITERAL [ 3 ] LITERAL >
  334.  
  335.   [ 5 ] LITERAL [ 5 ] LITERAL =
  336.   [ 3 ] LITERAL [ 5 ] LITERAL <
  337.   [ 3 ] LITERAL [ 5 ] LITERAL >
  338. END
  339.  
  340. run LOGIC-TEST
  341.  
  342. DEFINE ARITHMETIC-TEST ( -- )
  343.   [ 5 ] LITERAL NEGATE
  344.  
  345.   [ 5 ] LITERAL ABS
  346.   [ -5 ] LITERAL ABS
  347.  
  348.   [ 5 ] LITERAL [ 3 ] LITERAL MAX
  349.   [ 5 ] LITERAL [ 3 ] LITERAL MIN
  350.   
  351.   [ 5 ] LITERAL [ 3 ] LITERAL +
  352.   [ 5 ] LITERAL [ 3 ] LITERAL -
  353.  
  354.   [ 5 ] LITERAL [ 3 ] LITERAL *
  355.   [ 5 ] LITERAL [ -3 ] LITERAL *
  356.   [ -5 ] LITERAL [ 3 ] LITERAL *
  357.   [ -5 ] LITERAL [ -3 ] LITERAL *
  358.  
  359.   [ 5 ] LITERAL [ 3 ] LITERAL /MOD
  360.   [ 5 ] LITERAL [ -3 ] LITERAL /MOD
  361.   [ -5 ] LITERAL [ 3 ] LITERAL /MOD
  362.   [ -5 ] LITERAL [ -3 ] LITERAL /MOD
  363. END
  364.  
  365. run ARITHMETIC-TEST 
  366.  
  367. DEFINE FIB ( n -- m)
  368.    DUP 1- 0= OVER 0= OR NOT
  369.    IF DUP 1- FIB SWAP 2- FIB + THEN
  370. END
  371.  
  372. DEFINE FIB-TEST ( -- )
  373.   [ 8 ] LITERAL FIB
  374. END
  375.  
  376. run FIB-TEST
  377.  
  378. DEFINE FAC ( n -- n!)
  379.   DUP IF DUP 1- FAC * ELSE DROP 1 THEN
  380. END  
  381.  
  382. DEFINE FAC-TEST ( -- )
  383.   [ 5 ] LITERAL FAC
  384. END
  385.   
  386. run FAC-TEST
  387.  
  388. forth only
  389.